home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
c
/
predicate.c
< prev
next >
Wrap
C/C++ Source or Header
|
1987-06-04
|
12KB
|
723 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
predicate.c
predicates
*/
#include "include.h"
Lnull()
{
check_arg(1);
if (vs_base[0] == Cnil)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lsymbolp()
{
check_arg(1);
if (type_of(vs_base[0]) == t_symbol)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Latom()
{
check_arg(1);
if (type_of(vs_base[0]) != t_cons)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lconsp()
{
check_arg(1);
if (type_of(vs_base[0]) == t_cons)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Llistp()
{
check_arg(1);
if (vs_base[0] == Cnil || type_of(vs_base[0]) == t_cons)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lnumberp()
{
enum type t;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_fixnum || t == t_bignum || t == t_ratio ||
t == t_shortfloat || t == t_longfloat ||
t == t_complex)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lintegerp()
{
enum type t;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_fixnum || t == t_bignum)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lrationalp()
{
enum type t;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_fixnum || t == t_bignum || t == t_ratio)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lfloatp()
{
enum type t;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_longfloat || t == t_shortfloat)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lcomplexp()
{
check_arg(1);
if (type_of(vs_base[0]) == t_complex)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lcharacterp()
{
check_arg(1);
if (type_of(vs_base[0]) == t_character)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lstringp()
{
check_arg(1);
if (type_of(vs_base[0]) == t_string)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lbit_vector_p()
{
check_arg(1);
if (type_of(vs_base[0]) == t_bitvector)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lvectorp()
{
enum type t;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_vector || t == t_string || t == t_bitvector)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lsimple_string_p()
{
check_arg(1);
if (type_of(vs_base[0]) == t_string &&
!vs_base[0]->st.st_adjustable &&
!vs_base[0]->st.st_hasfillp &&
vs_base[0]->st.st_displaced->c.c_car == Cnil)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lsimple_bit_vector_p()
{
check_arg(1);
if (type_of(vs_base[0]) == t_bitvector &&
!vs_base[0]->bv.bv_adjustable &&
!vs_base[0]->bv.bv_hasfillp &&
vs_base[0]->bv.bv_displaced->c.c_car == Cnil)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lsimple_vector_p()
{
enum type t;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_vector &&
!vs_base[0]->v.v_adjustable &&
!vs_base[0]->v.v_hasfillp &&
vs_base[0]->v.v_displaced->c.c_car == Cnil &&
(enum aelttype)vs_base[0]->v.v_elttype == aet_object)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Larrayp()
{
enum type t;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_array ||
t == t_vector || t == t_string || t == t_bitvector)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lpackagep()
{
check_arg(1);
if (type_of(vs_base[0]) == t_package)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lfunctionp()
{
enum type t;
object x;
check_arg(1);
t = type_of(vs_base[0]);
if (t == t_cfun || t == t_cclosure)
vs_base[0] = Ct;
else if (t == t_symbol) {
if (vs_base[0]->s.s_gfdef != OBJNULL &&
vs_base[0]->s.s_mflag == FALSE)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
} else if (t == t_cons) {
x = vs_base[0]->c.c_car;
if (x == Slambda || x == Slambda_block ||
x == Slambda_closure || x == Slambda_block_closure)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
} else
vs_base[0] = Cnil;
}
Lcompiled_function_p()
{
check_arg(1);
if (type_of(vs_base[0]) == t_cfun ||
type_of(vs_base[0]) == t_cclosure)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lcommonp()
{
check_arg(1);
if (type_of(vs_base[0]) != t_spice)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Leq()
{
check_arg(2);
if (vs_base[0] == vs_base[1])
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
vs_pop;
}
bool
eql(x, y)
object x, y;
{
enum type t;
if (x == y)
return(TRUE);
if ((t = type_of(x)) != type_of(y))
return(FALSE);
switch (t) {
case t_fixnum:
if (fix(x) == fix(y))
return(TRUE);
else
return(FALSE);
case t_bignum:
if (big_compare((struct bignum *)x,
(struct bignum *)y) == 0)
return(TRUE);
else
return(FALSE);
case t_ratio:
if (eql(x->rat.rat_num, y->rat.rat_num) &&
eql(x->rat.rat_den, y->rat.rat_den))
return(TRUE);
else
return(FALSE);
case t_shortfloat:
if (sf(x) == sf(y))
return(TRUE);
else
return(FALSE);
case t_longfloat:
if (lf(x) == lf(y))
return(TRUE);
else
return(FALSE);
case t_complex:
if (eql(x->cmp.cmp_real, y->cmp.cmp_real) &&
eql(x->cmp.cmp_imag, y->cmp.cmp_imag))
return(TRUE);
else
return(FALSE);
case t_character:
if (char_code(x) == char_code(y) &&
char_bits(x) == char_bits(y) &&
char_font(x) == char_font(y))
return(TRUE);
else
return(FALSE);
}
return(FALSE);
}
Leql()
{
check_arg(2);
if (eql(vs_base[0], vs_base[1]))
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
vs_pop;
}
bool
equal(x, y)
object x, y;
{
enum type t;
cs_check(x);
BEGIN:
if ((t = type_of(x)) != type_of(y))
return(FALSE);
if (eql(x, y))
return(TRUE);
switch (t) {
case t_cons:
if (!equal(x->c.c_car, y->c.c_car))
return(FALSE);
x = x->c.c_cdr;
y = y->c.c_cdr;
goto BEGIN;
case t_string:
return(string_eq(x, y));
case t_bitvector:
{
int i, ox, oy;
if (x->bv.bv_fillp != y->bv.bv_fillp)
return(FALSE);
ox = x->bv.bv_offset;
oy = y->bv.bv_offset;
for (i = 0; i < x->bv.bv_fillp; i++)
if((x->bv.bv_self[(i+ox)/8] & (0200>>(i+ox)%8))
!=(y->bv.bv_self[(i+oy)/8] & (0200>>(i+oy)%8)))
return(FALSE);
return(TRUE);
}
case t_structure:
{
int i;
if (x->str.str_name != y->str.str_name)
return(FALSE);
for (i = 0; i < x->str.str_length; i++)
if (!equal(x->str.str_self[i], y->str.str_self[i]))
return(FALSE);
return(TRUE);
}
case t_pathname:
#ifdef UNIX
if (equal(x->pn.pn_host, y->pn.pn_host) &&
equal(x->pn.pn_device, y->pn.pn_device) &&
equal(x->pn.pn_directory, y->pn.pn_directory) &&
equal(x->pn.pn_name, y->pn.pn_name) &&
equal(x->pn.pn_type, y->pn.pn_type) &&
equal(x->pn.pn_version, y->pn.pn_version))
#endif
#ifdef AOSVS
#endif
return(TRUE);
else
return(FALSE);
}
return(FALSE);
}
Lequal()
{
check_arg(2);
if (equal(vs_base[0], vs_base[1]))
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
vs_pop;
}
bool
equalp(x, y)
object x, y;
{
enum type tx, ty;
cs_check(x);
BEGIN:
if (eql(x, y))
return(TRUE);
tx = type_of(x);
ty = type_of(y);
switch (tx) {
case t_fixnum:
case t_bignum:
case t_ratio:
case t_shortfloat:
case t_longfloat:
case t_complex:
if (ty == t_fixnum || ty == t_bignum || ty == t_ratio ||
ty == t_shortfloat || ty == t_longfloat ||
ty == t_complex)
return(!number_compare(x, y));
else
return(FALSE);
case t_vector:
case t_string:
case t_bitvector:
if (ty == t_vector || ty == t_string || ty == t_bitvector)
goto ARRAY;
else
return(FALSE);
case t_array:
if (ty == t_array && x->a.a_rank != y->a.a_rank)
goto ARRAY;
else
return(FALSE);
}
if (tx != ty)
return(FALSE);
switch (tx) {
case t_character:
return(char_equal(x, y));
case t_cons:
if (!equalp(x->c.c_car, y->c.c_car))
return(FALSE);
x = x->c.c_cdr;
y = y->c.c_cdr;
goto BEGIN;
case t_structure:
{
int i;
if (x->str.str_name != y->str.str_name)
return(FALSE);
for (i = 0; i < x->str.str_length; i++)
if (!equalp(x->str.str_self[i], y->str.str_self[i]))
return(FALSE);
return(TRUE);
}
case t_pathname:
return(equal(x, y));
}
return(FALSE);
ARRAY:
{
int i, j;
if (x->a.a_dim != y->a.a_dim)
return(FALSE);
vs_push(Cnil);
vs_push(Cnil);
for (i = 0, j = x->a.a_dim; i < j; i++) {
vs_top[-2] = aref(x, i);
vs_top[-1] = aref(y, i);
if (!equalp(vs_top[-2], vs_top[-1])) {
vs_pop;
vs_pop;
return(FALSE);
}
}
vs_pop;
vs_pop;
return(TRUE);
}
}
Lequalp()
{
check_arg(2);
if (equalp(vs_base[0], vs_base[1]))
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
vs_pop;
}
Fand(args)
object args;
{
object *top = vs_top;
if (endp(args)) {
vs_base = vs_top;
vs_push(Ct);
return;
}
while (!endp(MMcdr(args))) {
eval(MMcar(args));
if (vs_base[0] == Cnil) {
vs_base = vs_top = top;
vs_push(Cnil);
return;
}
vs_top = top;
args = MMcdr(args);
}
eval(MMcar(args));
}
For(args)
object args;
{
object *top = vs_top;
if (endp(args)) {
vs_base = vs_top;
vs_push(Cnil);
return;
}
while (!endp(MMcdr(args))) {
eval(MMcar(args));
if (vs_base[0] != Cnil) {
top[0] = vs_base[0];
vs_base = top;
vs_top = top+1;
return;
}
vs_top = top;
args = MMcdr(args);
}
eval(MMcar(args));
}
/*
Contains_sharp_comma returns TRUE, iff the argument contains
a cons whose car is si:|#,| or a STRUCTURE.
Refer to the compiler about this magic.
*/
bool
contains_sharp_comma(x)
object x;
{
enum type tx;
cs_check(x);
BEGIN:
tx = type_of(x);
if (tx == t_complex)
return(contains_sharp_comma(x->cmp.cmp_real) ||
contains_sharp_comma(x->cmp.cmp_imag));
if (tx == t_vector)
{
int i;
for (i = 0; i < x->v.v_fillp; i++)
if (contains_sharp_comma(x->v.v_self[i]))
return(TRUE);
return(FALSE);
}
if (tx == t_cons) {
if (x->c.c_car == siSsharp_comma)
return(TRUE);
if (contains_sharp_comma(x->c.c_car))
return(TRUE);
x = x->c.c_cdr;
goto BEGIN;
}
if (tx == t_array)
{
int i, j;
for (i = 0, j = 1; i < x->a.a_rank; i++)
j *= x->a.a_dims[i];
for (i = 0; i < j; i++)
if (contains_sharp_comma(x->a.a_self[i]))
return(TRUE);
return(FALSE);
}
if (tx == t_structure)
return(TRUE); /* Oh, my god! */
return(FALSE);
}
siLcontains_sharp_comma()
{
check_arg(1);
if (contains_sharp_comma(vs_base[0]))
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
siLspicep()
{
check_arg(1);
if (type_of(vs_base[0]) == t_spice)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
siLfixnump()
{
check_arg(1);
if (type_of(vs_base[0]) == t_fixnum)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
init_predicate_function()
{
make_function("NULL", Lnull);
make_function("SYMBOLP", Lsymbolp);
make_function("ATOM", Latom);
make_function("CONSP", Lconsp);
make_function("LISTP", Llistp);
make_function("NUMBERP", Lnumberp);
make_function("INTEGERP", Lintegerp);
make_function("RATIONALP", Lrationalp);
make_function("FLOATP", Lfloatp);
make_function("COMPLEXP", Lcomplexp);
make_function("CHARACTERP", Lcharacterp);
make_function("STRINGP", Lstringp);
make_function("BIT-VECTOR-P", Lbit_vector_p);
make_function("VECTORP", Lvectorp);
make_function("SIMPLE-STRING-P", Lsimple_string_p);
make_function("SIMPLE-BIT-VECTOR-P", Lsimple_bit_vector_p);
make_function("SIMPLE-VECTOR-P", Lsimple_vector_p);
make_function("ARRAYP", Larrayp);
make_function("PACKAGEP", Lpackagep);
make_function("FUNCTIONP", Lfunctionp);
make_function("COMPILED-FUNCTION-P", Lcompiled_function_p);
make_function("COMMONP", Lcommonp);
make_function("EQ", Leq);
make_function("EQL", Leql);
make_function("EQUAL", Lequal);
make_function("EQUALP", Lequalp);
make_function("NOT", Lnull);
make_special_form("AND",Fand);
make_special_form("OR",For);
make_si_function("CONTAINS-SHARP-COMMA", siLcontains_sharp_comma);
make_si_function("FIXNUMP", siLfixnump);
make_si_function("SPICEP", siLspicep);
}